{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.AfmLoader.Parser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser for AFM files.
--
--------------------------------------------------------------------------------

module Wumpus.AfmLoader.Parser
  ( 
    
    parseAfmFile

  , afmFontMetrics

  ) where


import Wumpus.AfmLoader.Datatypes
import qualified Wumpus.AfmLoader.LexemeParser as P

import Wumpus.Core                              -- package: wumpus-core

import Text.Parsec                              -- package: parsec
import Text.Parsec.Perm
import Text.Parsec.String


import Control.Applicative hiding ( many , (<|>) )
import qualified Data.Map as M

type HeaderTable = M.Map String String

data TableParser a = TP String (Parser a)

runTableParser :: HeaderTable -> TableParser a -> Maybe a
runTableParser m (TP key p) = M.lookup key m >>= sk
  where
    sk = either (const Nothing) Just . parse p ""

parseAfmFile :: FilePath -> IO (Either ParseError AfmFile)
parseAfmFile = parseFromFile undefined

parseLineField :: String -> Parser a -> Parser a
parseLineField name p = try (symbol name) *> p <* newline


unstructuredValue :: Parser String
unstructuredValue = many (noneOf "\n")

{-

--
-- NOTE - perm parsing doesn\'t seem to work with extra 
-- (unrecognized) fields.
--

afmFontMetrics      :: Parser AfmFontMetrics
afmFontMetrics      = versionNumber >>= \ix -> 
    permute ((AfmFontMetrics ix) <$?> pOpt fullName
                                 <|?> pOpt encodingScheme
                                 <|?> pOpt fontBBox
                                 <|?> pOpt capHeight
                                 <|?> pOpt ascender
                                 <|?> pOpt descender
                                 <|?> pOpt underlinePosition
                                 <|?> pOpt underlineThickness )
                               


pOpt :: Parser a -> (Maybe a, Parser (Maybe a))
pOpt p = (Nothing, fmap Just p)
-}



afmFontMetrics      :: Parser AfmFontMetrics
afmFontMetrics      = 
    versionNumber >>= \ix -> 
    headerTable   >>= \ht -> 
    return $ AfmFontMetrics
      { afm_file_format           = ix
      , afm_font_fullname         = runTableParser ht fullName
      , afm_encoding              = runTableParser ht encodingScheme
      , afm_font_bbox             = runTableParser ht fontBBox
      , afm_cap_height            = runTableParser ht capHeight
      , afm_ascender              = runTableParser ht ascender
      , afm_descender             = runTableParser ht descender
      , afm_underline_position    = runTableParser ht underlinePosition
      , afm_underline_thickness   = runTableParser ht underlineThickness
      }


-- | Consumes the StartFontMetrics line.
--
versionNumber       :: Parser String
versionNumber       = symbol "StartFontMetrics" *> p <* newline
  where
    p = many1 (digit <|> oneOf ".")



headerTable :: Parser HeaderTable
headerTable = M.fromList <$> manyTill p (symbol "StartCharMetrics")
  where
    p = (,) <$> lexeme (many1 alphaNum) <*> (unstructuredValue <* newline)


fullName            :: TableParser String
fullName            = TP "FullName" unstructuredValue


underlinePosition   :: TableParser AfmUnit
underlinePosition   = TP "UnderlinePosition" int

underlineThickness  :: TableParser AfmUnit
underlineThickness  = TP "UnderlineThickness" int

encodingScheme      :: TableParser String
encodingScheme      = TP "EncodingScheme" unstructuredValue

fontBBox            :: TableParser (BoundingBox AfmUnit)
fontBBox            = TP "FontBBox" p
  where
    p = (\x1 y1 x2 y2 -> BBox (P2 x1 y1) (P2 x2 y2) )
          <$> int <*> int <*> int <*> int

capHeight           :: TableParser AfmUnit
capHeight           = TP "CapHeight" int

ascender            :: TableParser AfmUnit
ascender            = TP "Ascender" int

descender           :: TableParser AfmUnit
descender           = TP "Descender" int


--------------------------------------------------------------------------------
-- lexical

lx :: P.LexerSimple
lx = P.arbCharLexemeParser [ ' ', '\t' ]


lexeme          :: Parser a -> Parser a
lexeme p        = P.lexeme lx p

whiteSpace      :: Parser ()
whiteSpace      = P.whiteSpace lx

symbol          :: String -> Parser String
symbol          = P.symbol lx

int             :: Parser AfmUnit
int             = fromIntegral <$> P.int lx 

semi            :: Parser String
semi            = P.semi lx

